; Simulation package.				-*-Mode:LISP; Base:10-*-

; This file includes:
; 1. Random number utilities.
; 2. A simulation driver.
; 3. A queue manager.
; 4. A simple M/M/1 test system.

; Set reasonable number base.
(eval-when (compile load eval)
 (setq base (+ 8 2) ibase (+ 8 2) *nopoint t))

; Output macros to FASL file.
#m(declare (macros t))
 
#m(eval-when (compile load eval)
 (load "alan;struct fasl"))

(defmacro increment (var &optional (delta 1))
  `(setf ,var (+ ,var ,delta)))

(defmacro decrement (var &optional (delta 1))
  `(setf ,var (- ,var ,delta)))

#m(declare (flonum (random-float flonum)))
(defun random-float ()
 (//$ (float (1+ (random 1000000)))
      1000000.0))

#m(declare (flonum (random-exponential flonum)))
(defun random-exponential (mean)
 (-$ (*$ (log (random-float))
	 mean)))


(defun test (form &optional (N 1000))
 (prog (sum sumsq)
  (setq sum 0.0 sumsq 0.0)
  (do i N (1- i) (= i 0)
      (let ((x (eval form)))
	   (setq sum (+$ sum x))
	   (setq sumsq (+$ sumsq (*$ x x)))
	   ))
  (let ((x (//$ sum (float N))))
       (let ((y (sqrt (-$ (//$ sumsq (float N))
			  (*$ x x)))))
	    (terpri)
	    (format t "Average = }s, standard deviation = }s" x y)))))

;;; Simulation Driver


; EVENT-LIST is a list of (TIME . EVENT) pairs sorted by TIME.
; EVENT-AT-TIME adds to this list, and RUN removes things from it.
; It is initialized by RUN.
(declare (special event-list))

; (EVENT-AT-TIME EVENT TIME) causes EVENT to be funcall'd at TIME.
(defun event-at-time (event time)
 (cond ((or (null event-list)
	    (> (caar event-list) time))
	(setq event-list (cons (cons time event) event-list)))
       (t (do ((i event-list (cdr i)))
	      ((or (null (cdr i))
		   (> (caadr i) time))
	       (rplacd i (cons (cons time event) (cdr i))))
	      ))))


; CURRENT-TIME is set by RUN, and read by many event subroutines.  It
; represents time in the simulation run.
; CURRENT-EVENT is the name of the current event.  It is currently used
; only in RUN.
(declare (special current-time current-event))
(defvar event-trace ())

; (RUN DURATION) does a simulation run, terminating after DURATION clock
; units.  The user subroutine GENESIS is invoked at the beginning of time,
; and APOCALYPSE at the end of the simulation.  APOCALYPSE should
; finish with (*THROW 'DONE ()) to exit RUN.

(defun run (duration)
 (setq event-list ())				; no events yet
 (setq current-time 0)				; start time at zero for
						; error check below
 (event-at-time #'genesis 0)			; GENESIS will invoke other
						; events
 (event-at-time #'apocalypse duration)		; APOCALYPSE after the
						; specified length of time
 (*catch 'done
  (do ()					; loop
      ((null event-list)			; if EVENT-LIST becomes null
       (format t "}%Premature end of world")	; then terminate abnormally
       (apocalypse))				; still call user subroutine
      ; get next event from EVENT-LIST and do it
      (cond ((< (caar event-list) current-time)
	     (error "Attempt to warp time!")))
      (setq current-time (caar event-list)	; set CURRENT-TIME to time of
						; next event
	    current-event (cdar event-list)	; set CURRENT-EVENT to
						; subroutine to call
	    event-list (cdr event-list))
      (if event-trace
	  (format t "}%T = }s, calling }s" current-time current-event))
      (funcall current-event))			; call event subroutine
  ))

;;; Queues

(defstruct (queue #q :named) 
  (queue-list ())
  (queue-length 0)
  (queue-last-operation 0)
  (queue-time-length-product 0)
  (maximum-queue-length 0)
  queue-name
  )
  
(defun create-queue (name)
  (make-queue queue-name name))

(defun update-queue-statistics (queue)
  (increment (queue-time-length-product queue)
	     (* (- current-time (queue-last-operation queue))
		(queue-length queue)))
  (setf (queue-last-operation queue) current-time))

(defun enqueue (object queue)
  (update-queue-statistics queue)
  (setf (queue-list queue) (nconc (queue-list queue) (ncons object)))
  (increment (queue-length queue))
  (setf (maximum-queue-length queue) (max (maximum-queue-length queue)
					  (queue-length queue))))

(defun dequeue (queue)
  (if (null (queue-list queue))			; if nothing in queue
      ()					; return ()
      (prog1 (car (queue-list queue))
	     (update-queue-statistics queue)
	     (setf (queue-list queue) (cdr (queue-list queue)))
	     (decrement (queue-length queue)))))

(defun print-queue-statistics (queue)
  (update-queue-statistics queue)
  (format t "}%}a length: average = }s, maximum = }s"
	  (queue-name queue)
	  (//$ (float (queue-time-length-product queue))
	       (float current-time))
	  (maximum-queue-length queue)))

;;; M/M/1 test system.


; Requests are currently just a fixnum.  Should be a structure for
; tracking request service time, etc.
(defun create-request (service-time) service-time)
(defun service-time (request) request)


; Define/default mean service time and arrival rate.
(defvar mean-service-time 900.0)
(defvar mean-arrival-interval 1000.0)

(defun set-utilization (u)
 (setq mean-service-time (*$ mean-arrival-interval u)))


(defvar busy)					; set if server is busy
(defvar server-queue)				; used to queue requests
						; while server is busy
(defvar server-time)				; total time sever busy
(defvar start-of-service)			; time last service began

; Event for arrival of a new request.
(defun arrival ()
 (let ((request (create-request (fix (random-exponential mean-service-time))))
       (next (fix (random-exponential mean-arrival-interval))))
      (event-at-time #'arrival (+ current-time next))
      (if busy
	  (enqueue request server-queue)
	  (service request))
      ))

; Service a request.
(defun service (request)
 (setq start-of-service current-time)
 (setq busy t)
 (event-at-time #'departure (+ current-time (service-time request))))

; Event for service completion.  Update statistics and service next request
; in queue, if any.
(defun departure ()
 (increment server-time (- current-time start-of-service))
 (setq busy ())
 (let ((request (dequeue server-queue)))
   (if (not (null request))
       (service request))))

(defun print-server-statistics ()
 (if busy (increment server-time (- current-time start-of-service)))
 (format t "}%server utilization = }s"
	 (//$ (float server-time) (float current-time))))

(defun Genesis ()
 (format t "}%Begin queuing simulation with utilization = }s}%"
	 (//$ mean-service-time
	      mean-arrival-interval))
 (setq server-queue (create-queue "server queue"))	; create queue
 (setq busy ())					; mark server as idle
 (setq server-time 0)
 (arrival))					; start off with an arrival

(defun Apocalypse ()
 (format t "}%End simulation at T = }s}%" current-time)
 (print-server-statistics)
 (print-queue-statistics server-queue)
 (*throw 'done ()))
ββ